improved contract libraries handling of #%app for provide/contract'd variables

svn: r7590

collects/mzlib/private/contract.ss

@@ -100,10 +100,12 @@ improve method arity mismatch contract violation error messages?
                 ;; Expand to a use of the lifted expression:
                 (with-syntax ([saved-id (syntax-local-introduce (hash-table-get saved-id-table key))])
                   (syntax-case stx (set!)
-                    [(name arg ...) (syntax/loc stx (saved-id arg ...))]
                     [name
                      (identifier? (syntax name))
-                     (syntax saved-id)])))
+                     (syntax saved-id)]
+                    [(name . more)
+                     (with-syntax ([app (datum->syntax-object stx '#%app)])
+                       (syntax/loc stx (app saved-id . more)))])))
               ;; In case of partial expansion for module-level and internal-defn contexts,
               ;; delay expansion until it's a good time to lift expressions:
               (quasisyntax/loc stx (#%expression #,stx)))))))

collects/tests/mzscheme/contract-test.ss

@@ -5211,6 +5211,22 @@ so that propagation occurs.
                (c:case-> (c:-> integer? integer?)
                          (c:-> integer? integer? integer?))))))
   
+  ;; tests that contracts pick up the #%app from the context
+  ;; instead of always using the mzscheme #%app.
+  (test/spec-passed
+   'provide/contract25
+   '(begin
+      (eval '(module provide/contract25a mzscheme
+               (require (lib "contract.ss"))
+               (provide/contract [seventeen integer?])
+               (define seventeen 17)))
+      (eval '(module provide/contract25b mzscheme
+               (require provide/contract25a)
+               (let-syntax ([#%app (syntax-rules ()
+                                     [(#%app e ...) (list e ...)])])
+                 (seventeen 18))))
+      (eval '(require provide/contract25b))))
+
   (contract-error-test
    #'(begin
        (eval '(module pce1-bug mzscheme