diff --git a/scheme/last-revision b/scheme/last-revision
index 86fc8f4..1c95f53 100644
--- a/scheme/last-revision
+++ b/scheme/last-revision
@@ -1 +1 @@
-1862
+1863
diff --git a/scheme/psyntax.expander.ss b/scheme/psyntax.expander.ss
index ca9e674..7039a45 100644
--- a/scheme/psyntax.expander.ss
+++ b/scheme/psyntax.expander.ss
@@ -413,15 +413,57 @@
             (make-stx (stx-expr e) m* s* ae*))
           (make-stx e m* s* ae*))))
   
-  ;;; to add a mark, we always add a corresponding shift.
-  (define add-mark
-    (lambda (m e ae)
-      (mkstx e (list m) '(shift) (list ae))))
-
   (define add-subst
     (lambda (subst e)
       (mkstx e '() (list subst) '())))
 
+  (define add-mark
+    (lambda (mark subst expr ae)
+      (define merge-ae*
+        (lambda (ls1 ls2)
+          (if (and (pair? ls1) (pair? ls2) (not (car ls2)))
+              (cancel ls1 ls2)
+              (append ls1 ls2))))
+      (define cancel
+        (lambda (ls1 ls2)
+          (let f ((x (car ls1)) (ls1 (cdr ls1)))
+            (if (null? ls1)
+                (cdr ls2)
+                (cons x (f (car ls1) (cdr ls1)))))))
+      (define (f e m s1* ae*)
+        (cond
+          [(pair? e)
+           (let ([a (f (car e) m s1* ae*)] 
+                 [d (f (cdr e) m s1* ae*)])
+             (if (eq? a d) e (cons a d)))]
+          [(vector? e) 
+           (let ([ls1 (vector->list e)])
+             (let ([ls2 (map (lambda (x) (f x m s1* ae*)) ls1)])
+               (if (for-all eq? ls1 ls2) e (list->vector ls2))))]
+          [(stx? e)
+           (let ([m* (stx-mark* e)] [s2* (stx-subst* e)])
+             (cond
+               [(null? m*)
+                (f (stx-expr e) m 
+                   (append s1* s2*)
+                   (merge-ae* ae* (stx-ae* e)))]
+               [(eq? (car m*) anti-mark)
+                (make-stx (stx-expr e) (cdr m*)
+                  (cdr (append s1* s2*))
+                  (merge-ae* ae* (stx-ae* e)))]
+               [else
+                (make-stx (stx-expr e)
+                  (cons m m*)
+                  (let ([s* (cons 'shift (append s1* s2*))])
+                    (if subst (cons subst s*) s*))
+                  (merge-ae* ae* (stx-ae* e)))]))]
+          [(symbol? e)
+           (syntax-violation #f 
+               "raw symbol encountered in output of macro"
+               expr e)]
+          [else (make-stx e (list m) s1* ae*)]))
+      (mkstx (f expr mark '() '()) '() '() (list ae))))
+
   ;;; now are some deconstructors and predicates for syntax objects.
   (define syntax-kind?
     (lambda (x p?)
@@ -2678,7 +2720,7 @@
   (define (local-macro-transformer x)
     (car x))
 
-  (define (do-macro-call transformer expr r)
+  (define (do-macro-call transformer expr r rib)
     (define (return x)
       (let f ((x x))
         ;;; don't feed me cycles.
@@ -2690,8 +2732,8 @@
              (syntax-violation #f 
                "raw symbol encountered in output of macro"
                expr x)))))
-      (add-mark (gen-mark) x expr))
-    (let ((x (transformer (add-mark anti-mark expr #f))))
+      (add-mark (gen-mark) rib x expr))
+    (let ((x (transformer (add-mark anti-mark #f expr #f))))
       (if (procedure? x) 
           (return 
             (x (lambda (id)
@@ -2711,13 +2753,13 @@
           (return x))))
 
   ;;; chi procedures
-  (define chi-macro
-    (lambda (p e r) (do-macro-call (macro-transformer p) e r)))
+  (define (chi-macro p e r rib)
+    (do-macro-call (macro-transformer p) e r rib))
   
-  (define chi-local-macro
-    (lambda (p e r) (do-macro-call (local-macro-transformer p) e r)))
+  (define (chi-local-macro p e r rib)
+    (do-macro-call (local-macro-transformer p) e r rib))
   
-  (define (chi-global-macro p e r)
+  (define (chi-global-macro p e r rib)
     (let ((lib (car p))
           (loc (cdr p)))
       (unless (eq? lib '*interaction*)
@@ -2732,7 +2774,7 @@
                   (cdr x))
                  (else (assertion-violation 'chi-global-macro
                           "BUG: not a procedure" x)))))
-          (do-macro-call transformer e r)))))
+          (do-macro-call transformer e r rib)))))
   
   (define chi-expr*
     (lambda (e* r mr)
@@ -2752,8 +2794,6 @@
              rator
              (chi-expr* rands r mr)))))))
 
-
-
   (define chi-expr
     (lambda (e r mr)
       (let-values (((type value kwd) (syntax-type e r)))
@@ -2774,9 +2814,11 @@
            (let ((lex (lexical-var value)))
              (build-lexical-reference no-source lex)))
           ((global-macro global-macro!)
-           (chi-expr (chi-global-macro value e r) r mr))
-          ((local-macro local-macro!) (chi-expr (chi-local-macro value e r) r mr))
-          ((macro macro!) (chi-expr (chi-macro value e r) r mr))
+           (chi-expr (chi-global-macro value e r #f) r mr))
+          ((local-macro local-macro!) 
+           (chi-expr (chi-local-macro value e r #f) r mr))
+          ((macro macro!)
+           (chi-expr (chi-macro value e r #f) r mr))
           ((constant)
            (let ((datum value))
              (build-data no-source datum)))
@@ -2853,9 +2895,9 @@
              ((global)
               (stx-error e "attempt to modify an immutable binding"))
              ((global-macro!)
-              (chi-expr (chi-global-macro value e r) r mr))
+              (chi-expr (chi-global-macro value e r #f) r mr))
              ((local-macro!)
-              (chi-expr (chi-local-macro value e r) r mr))
+              (chi-expr (chi-local-macro value e r #f) r mr))
              ((mutable) 
               (if (and (pair? value) (let ((lib (car value))) (eq? lib '*interaction*)))
                   (let ([loc (cdr value)])
@@ -3107,24 +3149,6 @@
                               (cons (cons lab (cons '$module iface)) mr)
                               mod** kwd*)))))))))
 
-  (define (copy-rib-contents! from-rib to-rib sd?)
-    (for-each
-      (lambda (sym mark* label)
-        (let ([id (make-stx sym mark* '() '())])
-          (extend-rib! to-rib id label sd?)))
-      (rib-sym* from-rib) (rib-mark** from-rib) (rib-label* from-rib)))
-
-  (define chi-body*-macro
-    (lambda (e* r mr lex* rhs* mod** kwd* exp* rib mix? sd? e)
-      (let ([rib2 (make-empty-rib)])
-        (let-values ([(e1* r mr lex* rhs* mod** kwd* exp*)
-                      (chi-body* (list (add-subst rib2 e)) 
-                        r mr lex* rhs* mod** kwd* exp* rib2 mix? sd?)])
-          (copy-rib-contents! rib2 rib sd?)
-          (if (null? e1*)
-              (chi-body* e* r mr lex* rhs* mod** kwd* exp* rib mix? sd?)
-              (values (append e1* e*) r mr lex* rhs* mod** kwd* exp*))))))
-
   (define chi-body*
     (lambda (e* r mr lex* rhs* mod** kwd* exp* rib mix? sd?)
       (cond
@@ -3207,17 +3231,17 @@
                           r mr lex* rhs* mod** kwd* exp* rib
                           mix? sd?)))))
                  ((global-macro global-macro!)
-                  (chi-body*-macro (cdr e*)
-                     r mr lex* rhs* mod** kwd* exp* rib mix? sd?
-                     (chi-global-macro value e r)))
+                  (chi-body* 
+                    (cons (chi-global-macro value e r rib) (cdr e*))
+                    r mr lex* rhs* mod** kwd* exp* rib mix? sd?))
                  ((local-macro local-macro!)
-                  (chi-body*-macro (cdr e*)
-                     r mr lex* rhs* mod** kwd* exp* rib mix? sd?
-                     (chi-local-macro value e r))) 
+                  (chi-body* 
+                    (cons (chi-local-macro value e r rib) (cdr e*))
+                    r mr lex* rhs* mod** kwd* exp* rib mix? sd?))
                  ((macro macro!)
-                  (chi-body*-macro (cdr e*)
-                     r mr lex* rhs* mod** kwd* exp* rib mix? sd?
-                     (chi-macro value e r)))
+                  (chi-body* 
+                    (cons (chi-macro value e r rib) (cdr e*))
+                    r mr lex* rhs* mod** kwd* exp* rib mix? sd?))
                  ((module)
                   (let-values (((lex* rhs* m-exp-id* m-exp-lab* r mr mod** kwd*)
                                 (chi-internal-module e r mr lex* rhs* mod** kwd*)))