better tracking of lexical context for unwrapped syntax objects

svn: r14692

collects/r6rs/private/reconstruct.ss

@@ -0,0 +1,4 @@
+#lang scheme/base
+
+(provide reconstruction-memory)
+(define reconstruction-memory (make-weak-hasheq))

collects/rnrs/base-6.ss

@@ -7,6 +7,7 @@
          scheme/splicing
          r6rs/private/qq-gen
          r6rs/private/exns
+         (for-syntax r6rs/private/reconstruct)
          (prefix-in r5rs: r5rs)
          (only-in r6rs/private/readtable rx:number)
          scheme/bool)
@@ -561,11 +562,14 @@
    [(symbol? r) (error 'macro
                        "transformer result included a raw symbol: ~e"
                        r)]
-   [(mpair? r) (datum->syntax
-                stx
-                (cons (wrap (mcar r) stx)
-                      (wrap (mcdr r) stx))
-                stx)]
+   [(mpair? r) 
+    (let ([istx (or (hash-ref reconstruction-memory r #f)
+                    stx)])
+      (datum->syntax
+       istx
+       (cons (wrap (mcar r) stx)
+             (wrap (mcdr r) stx))
+       istx))]
    [(vector? r) (datum->syntax
                  stx
                  (list->vector

collects/rnrs/syntax-case-6.ss

@@ -2,6 +2,7 @@
 
 (require (for-syntax scheme/base)
          r6rs/private/qq-gen
+         r6rs/private/reconstruct
          scheme/mpair
          r6rs/private/exns
          (for-syntax syntax/template
@@ -179,6 +180,8 @@
 ;; ----------------------------------------
 
 (define (unwrap-reconstructed data stx datum)
+  (when (mpair? datum)
+    (hash-set! reconstruction-memory datum (datum->syntax stx 'memory stx)))
   datum)
 
 (define (unwrap-pvar data stx)
@@ -187,7 +190,10 @@
     (cond
      [(syntax? v)
       (if (eq? (syntax-source v) unwrapped-tag)
-          (loop (syntax-e v))
+          (let ([r (loop (syntax-e v))])
+            (when (mpair? r)
+              (hash-set! reconstruction-memory r (datum->syntax v 'memory v)))
+            r)
           v)]
      [(pair? v) (mcons (loop (car v))
                        (loop (cdr v)))]