From 5a1f31668d00469284ba9712078fdd2e854df53c Mon Sep 17 00:00:00 2001
From: Stevie Strickland <sstrickl@racket-lang.org>
Date: Mon, 23 Feb 2009 22:22:06 +0000
Subject: [PATCH] More name-setting fun.

svn: r13807
---
 collects/mzlib/private/unit-contract.ss | 8 +++++---
 collects/mzlib/unit.ss                  | 1 +
 2 files changed, 6 insertions(+), 3 deletions(-)

diff --git a/collects/mzlib/private/unit-contract.ss b/collects/mzlib/private/unit-contract.ss
index 2447abfafa..7289ad41fe 100644
--- a/collects/mzlib/private/unit-contract.ss
+++ b/collects/mzlib/private/unit-contract.ss
@@ -3,6 +3,7 @@
 (require (for-syntax scheme/base
                      stxclass
                      syntax/boundmap
+                     syntax/name
                      "unit-compiletime.ss"
                      "unit-contract-syntax.ss"
                      "unit-syntax.ss")
@@ -134,7 +135,7 @@ packed with the neg blame.
 (define-for-syntax contract-imports (contract-imports/exports #t))
 (define-for-syntax contract-exports (contract-imports/exports #f))
 
-(define-for-syntax (unit/c/core stx)
+(define-for-syntax (unit/c/core name stx)
   (syntax-parse stx
     [(:import-clause/c :export-clause/c)
      (begin
@@ -225,7 +226,7 @@ packed with the neg blame.
                           (vector-immutable export-key ...)) ...)
                    src-info pos name)
                   (make-unit
-                   #f
+                   '#,name
                    (vector-immutable (cons 'import-name
                                            (vector-immutable import-key ...)) ...)
                    (vector-immutable (cons 'export-name 
@@ -269,7 +270,8 @@ packed with the neg blame.
 (define-syntax/err-param (unit/c stx)
   (syntax-case stx ()
     [(_ . sstx)
-     (unit/c/core #'sstx)]))
+     (let ([name (syntax-local-infer-name stx)])
+       (unit/c/core name #'sstx))]))
 
 (define (contract-check-helper sub-sig super-sig import? val src-info blame ctc)
   (define t (make-hash))
diff --git a/collects/mzlib/unit.ss b/collects/mzlib/unit.ss
index 64eed9164e..b93bc54627 100644
--- a/collects/mzlib/unit.ss
+++ b/collects/mzlib/unit.ss
@@ -1482,6 +1482,7 @@
            (with-syntax ([new-unit exp]
                          [unit-contract
                           (unit/c/core
+                           #'name
                            (syntax/loc stx
                              ((import (import-tagged-sig-id [i.x i.c] ...) ...)
                               (export (export-tagged-sig-id [e.x e.c] ...) ...))))]