From 78dbc225981e467c8399b5aca535b9e69ccb1a72 Mon Sep 17 00:00:00 2001
From: Stevie Strickland <sstrickl@racket-lang.org>
Date: Mon, 23 Feb 2009 21:46:22 +0000
Subject: [PATCH] Try to set up the inferred-name property appropriately.

svn: r13805
---
 collects/mzlib/private/unit-contract.ss | 16 ++++----
 collects/mzlib/private/unit-utils.ss    | 14 +++----
 collects/mzlib/unit.ss                  | 49 +++++++++++++------------
 3 files changed, 41 insertions(+), 38 deletions(-)

diff --git a/collects/mzlib/private/unit-contract.ss b/collects/mzlib/private/unit-contract.ss
index a3813b91e2..a7e6a8fdb1 100644
--- a/collects/mzlib/private/unit-contract.ss
+++ b/collects/mzlib/private/unit-contract.ss
@@ -60,13 +60,15 @@ packed with the neg blame.
                ;; If contract coersion ends up being a large overhead, we can
                ;; store the result in a local box, then just check the box to
                ;; see if we need to coerce.
-               #`(let ([ctc (coerce-contract 'unit/c (letrec-syntax #,rename-bindings #,ctc))])
-                   ((((proj-get ctc) ctc)
-                     #,(if import? neg pos)
-                     #,(if import? pos neg)
-                     #,src-info
-                     #,name)
-                    #,stx)))])
+               (with-syntax ([ctc-stx (syntax-property #`(letrec-syntax #,rename-bindings #,ctc)
+                                                       'inferred-name var)])
+                 #`(let ([ctc (coerce-contract 'unit/c ctc-stx)])
+                     ((((proj-get ctc) ctc)
+                       #,(if import? neg pos)
+                       #,(if import? pos neg)
+                       #,src-info
+                       #,name)
+                      #,stx))))])
         (if ctc
             #`(cons
                #,(if import?
diff --git a/collects/mzlib/private/unit-utils.ss b/collects/mzlib/private/unit-utils.ss
index e4d8ac53bb..baf6a35cb1 100644
--- a/collects/mzlib/private/unit-utils.ss
+++ b/collects/mzlib/private/unit-utils.ss
@@ -43,13 +43,13 @@
   (for/list ([i (in-list (map car (car sig)))]
              [c (in-list (cadddr sig))])
     (let ([add-ctc
-           (λ (v stx)
-             (if c
-                 #`(let ([v/c ((car #,stx))])
-                     (contract (let ([#,v #,c]) #,v)
-                               (car v/c) (cdr v/c) #,blame
-                               #,(id->contract-src-info v)))
-                 #`((car #,stx))))])
+             (λ (v stx)
+                 (if c
+                     (with-syntax ([c-stx (syntax-property c 'inferred-name v)])
+                       #`(let ([v/c ((car #,stx))])
+                           (contract c-stx (car v/c) (cdr v/c) #,blame
+                                     #,(id->contract-src-info v))))
+                     #`((car #,stx))))])
       #`[#,i
          (make-set!-transformer
           (λ (stx)
diff --git a/collects/mzlib/unit.ss b/collects/mzlib/unit.ss
index 8bfd095388..0b25cdcba1 100644
--- a/collects/mzlib/unit.ss
+++ b/collects/mzlib/unit.ss
@@ -790,30 +790,31 @@
                                   [rename-bindings (get-member-bindings def-table
                                                                         (bound-identifier-mapping-get sig-table var)
                                                                         #'(current-contract-region))])
-                             (if (or target-ctc ctc)
-                                 #`(cons
-                                    (λ ()
-                                      (let ([old-v #,(if ctc
-                                                         #`(let ([old-v/c ((car #,vref))])
-                                                             (contract (let ([#,var (letrec-syntax #,rename-bindings #,ctc)]) #,var)
-                                                                       (car old-v/c) 
-                                                                       (cdr old-v/c) (current-contract-region)
-                                                                       #,(id->contract-src-info var)))
-                                                         #`((car #,vref)))])
-                                        #,(if target-ctc
-                                              #'(cons old-v (current-contract-region))
-                                              #'old-v)))
-                                    (λ (v) (let ([new-v #,(if ctc
-                                                              #`(contract (let ([#,var (letrec-syntax #,rename-bindings #,ctc)]) #,var)
-                                                                          (car v)
-                                                                          (current-contract-region)
-                                                                          (cdr v)
-                                                                          #,(id->contract-src-info var))
-                                                              #'v)])
-                                             #,(if target-ctc
-                                                   #`((cdr #,vref) (cons new-v (current-contract-region)))
-                                                   #`((cdr #,vref) new-v)))))
-                                 vref)))
+                             (with-syntax ([ctc-stx (if ctc (syntax-property
+                                                             #`(letrec-syntax #,rename-bindings #,ctc)
+                                                             'inferred-name var)
+                                                        ctc)])
+                               (if (or target-ctc ctc)
+                                   #`(cons
+                                      (λ ()
+                                        (let ([old-v #,(if ctc
+                                                           #`(let ([old-v/c ((car #,vref))])
+                                                               (contract ctc-stx (car old-v/c) 
+                                                                         (cdr old-v/c) (current-contract-region)
+                                                                         #,(id->contract-src-info var)))
+                                                           #`((car #,vref)))])
+                                          #,(if target-ctc
+                                                #'(cons old-v (current-contract-region))
+                                                #'old-v)))
+                                      (λ (v) (let ([new-v #,(if ctc
+                                                                #`(contract ctc-stx (car v)
+                                                                            (current-contract-region) (cdr v)
+                                                                            #,(id->contract-src-info var))
+                                                                #'v)])
+                                               #,(if target-ctc
+                                                     #`((cdr #,vref) (cons new-v (current-contract-region)))
+                                                     #`((cdr #,vref) new-v)))))
+                                   vref))))
                          (car target-sig)
                          (cadddr target-sig)))
                       target-import-sigs))