This system can even do operations on different types of polynomials. `adjoin-term` is not perfect. It can't adjoin a term in the middle of a polynomial correctly. I will fix it later.

 ; these have to be added to the polynomial package. So now it dispatches to 
 ; the generic procedures. 
   (define (the-empty-termlist term-list) 
     (let ((proc (get 'the-empty-termlist (type-tag term-list)))) 
     (if proc 
         (error "No proc found -- THE-EMPTY-TERMLIST" term-list)))) 
   (define (rest-terms term-list) 
     (let ((proc (get 'rest-terms (type-tag term-list)))) 
       (if proc 
           (proc term-list) 
           (error "-- REST-TERMS" term-list)))) 
   (define (empty-termlist? term-list) 
     (let ((proc (get 'empty-termlist? (type-tag term-list)))) 
       (if proc 
           (proc term-list) 
           (error "-- EMPTY-TERMLIST?" term-list)))) 
   (define (make-term order coeff) (list order coeff)) 
   (define (order term) 
     (if (pair? term) 
         (car term) 
         (error "Term not pair -- ORDER" term))) 
   (define (coeff term) 
     (if (pair? term) 
         (cadr term) 
         (error "Term not pair -- COEFF" term))) 
 ; here is the term-list package, which has the constructors and selectors for  
 ; the dense and sparse polynomials. 
 ; the generic first-term procedure.  
 (define (first-term term-list) 
   (let ((proc (get 'first-term (type-tag term-list)))) 
     (if proc 
         (proc term-list) 
         (error "No first-term for this list -- FIRST-TERM" term-list)))) 
 ; the pakcage with the constructors, selectors, and other helper procedures 
 ; I had to implement. 
 (define (install-polynomial-term-package) 
   (define (first-term-dense term-list) 
     (if (empty-termlist? term-list) 
          (- (length (cdr term-list)) 1) 
          (car (cdr term-list)))))   
   (define (first-term-sparse term-list) 
     (if (empty-termlist? term-list) 
         (cadr term-list))) 
   (define (prep-term-dense term) 
     (if (null? term) 
         (cdr term)))                    ;-> only the coeff for a dense term-list 
   (define (prep-term-sparse term) 
     (if (null? term) 
         (list term)))                   ;-> (order coeff) for a sparse term-list 
   (define (the-empty-termlist-dense) '(dense)) 
   (define (the-empty-termlist-sparse) '(sparse)) 
   (define (rest-terms term-list) (cons (type-tag term-list) (cddr term-list))) 
   (define (empty-termlist? term-list)  
     (if (pair? term-list)  
         (>= 1 (length term-list)) 
         (error "Term-list not pair -- EMPTY-TERMLIST?" term-list))) 
   (define (make-polynomial-dense var terms) 
     (make-polynomial var (cons 'dense (map cadr terms)))) 
   (define (make-polynomial-sparse var terms) 
     (make-polynomial var (cons 'sparse terms))) 
   (put 'first-term 'sparse  
        (lambda (term-list) (first-term-sparse term-list))) 
   (put 'first-term 'dense 
        (lambda (term-list) (first-term-dense term-list))) 
   (put 'prep-term 'dense 
        (lambda (term) (prep-term-dense term))) 
   (put 'prep-term 'sparse 
        (lambda (term) (prep-term-sparse term))) 
   (put 'rest-terms 'dense 
        (lambda (term-list) (rest-terms term-list))) 
   (put 'rest-terms 'sparse 
        (lambda (term-list) (rest-terms term-list))) 
   (put 'empty-termlist? 'dense 
        (lambda (term-list) (empty-termlist? term-list))) 
   (put 'empty-termlist? 'sparse 
        (lambda (term-list) (empty-termlist? term-list))) 
   (put 'the-empty-termlist 'dense 
        (lambda () (the-empty-termlist-dense))) 
   (put 'the-empty-termlist 'sparse 
        (lambda () (the-empty-termlist-sparse))) 
   (put 'make-polynomial 'sparse 
        (lambda (var terms) (make-polynomial-sparse var terms))) 
   (put 'make-polynomial 'dense 
        (lambda (var terms) (make-polynomial-dense var terms))) 
 ; I had to changhe the adjoin-term procedure. It now does  
 ; zero padding so we can `mul` dense polynomials correctly.  
   (define (zero-pad x type) 
     (if (eq? type 'sparse) 
         (if (= x 0) 
             (cons 0 (add-zeros (- x 1)))))) 
   (define (adjoin-term term term-list) 
     (let ((preped-term ((get 'prep-term (type-tag term-list)) term)) 
           (preped-first-term ((get 'prep-term (type-tag term-list)) 
                               (first-term term-list)))) 
       (cond ((=zero? (coeff term)) term-list)  
             ((empty-termlist? term-list) (append (the-empty-termlist term-list)  
                                                  (zero-pad (order term) 
             ((> (order term) (order (first-term term-list))) 
              (append (list (car term-list)) 
                      (zero-pad (- (- (order term) 
                                      (order (first-term term-list))) 
                                   1) (type-tag term-list)) 
                      (cdr term-list))) 
              (append preped-first-term  
                      (adjoin-term term (rest-terms term-list))))))) 
 ; here is `negate` now it creates a polynomial of the correct 
 ; type 
   (define (negate p) 
     (let ((neg-p ((get 'make-polynomial (type-tag (term-list p))) 
                   (variable p) (list (make-term 0 -1))))) 
       (mul-poly (cdr neg-p) p))) 

My solution is perhaps not as complete overall but I feel it is closer to what the authors would have expected since its approach is copied from section 2.4.3.

 (define (install-polynomial-dense-package) 
   (define (adjoin-term term term-list) 
     (if (= (order term) (length term-list)) 
         (cons (coeff term) term-list) 
         (adjoin-term term 
                      (cons 0 term-list)))) 
   (define (first-term term-list) 
     (make-term (car term-list) 
                (- (length term-list) 1))) 
   ; here place all the other procedures 
   (define (tag x) 
     (attach-tag 'polynomial-dense x)) 
   (put 'adjoin-term 'polynomial-dense 
        (lambda (term term-list) (tag (adjoin-term term term-list)))) 
   (put 'first-term 'polynomial-dense 
        (lambda (term-list) (tag (first-term term-list)))) 
   ; here place all the other calls to put 
 (define (install-polynomial-sparse-package) 
   (define (adjoin-term term term-list) 
     (if (=zero? (coeff term)) 
         (cons term term-list))) 
   (define (first-term term-list) (car term-list)) 
   ; here place all the other procedures 
   (define (tag x) 
     (attach-tag 'polynomial-sparse x)) 
   (put 'adjoin-term 'polynomial-sparse 
        (lambda (term term-list) (tag (adjoin-term term term-list)))) 
   (put 'first-term 'polynomial-sparse 
        (lambda (term-list) (tag (first-term term-list)))) 
   ; here place all the other calls to put 
 ; ommitted repeated procedures -- they would be the same for both packages 
 (define (make-poly variable term-list) 
   (if (poly-sparse? term-list) 
       ((get 'make-poly 'polynomial-sparse) term-list) 
       ((get 'make-poly 'polynomial-dense) term-list))) 
 (define (poly-sparse? term-list) 
   ; a polynomial is sparse if at least half of its coefficients are zero 
   (define (iter zeros remaining) 
     (cond ((null? remaining) 
           ((equ? (coeff (car remaining)) 0) 
            (iter (+ zeros 1) (cdr remaining))) 
            (iter zeros (cdr remaining))))) 
   ; the above could also be done with reduce 
   (> (iter 0 term-list) 
      (/ (length term-list) 2)))