More name-setting fun.

svn: r13807

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))

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] ...) ...))))]