added has-contract? and get-contract

svn: r18460

collects/scheme/contract/private/base.ss

@@ -11,7 +11,9 @@ improve method arity mismatch contract violation error messages?
 
 (provide contract
          recursive-contract
-         current-contract-region)
+         current-contract-region
+         has-contract?
+         get-contract)
 
 (require (for-syntax scheme/base)
          scheme/stxparam
@@ -40,9 +42,26 @@ improve method arity mismatch contract violation error messages?
 (define (apply-contract c v pos neg name loc)
   (let* ([c (coerce-contract 'contract c)])
     (check-source-location! 'contract loc)
-    (((contract-projection c)
-      (make-blame loc name (contract-name c) pos neg #t))
-     v)))
+    (remember-contract
+     (((contract-projection c)
+       (make-blame loc name (contract-name c) pos neg #t))
+      v)
+     c)))
+
+(define-struct contracted-function (f contract) #:property prop:procedure 0)
+(define (remember-contract f contract)
+  (cond
+    [(parameter? f) f]
+    [(procedure? f) (make-contracted-function f contract)]
+    [else f]))
+
+(define (has-contract? x) (contracted-function? x))
+(define (get-contract x) 
+  (unless (has-contract? x)
+    (raise-type-error 'get-contract
+                      "<has-contract>"
+                      x))
+  (contracted-function-contract x))
 
 (define-syntax (recursive-contract stx)
   (syntax-case stx ()

collects/scheme/contract/private/provide.ss

@@ -1,6 +1,9 @@
 #lang scheme/base
 
-(provide provide/contract (for-syntax make-provide/contract-transformer))
+(provide provide/contract 
+         (for-syntax make-provide/contract-transformer)
+         get-contract
+         has-contract?)
 
 (require (for-syntax scheme/base
                      scheme/list
@@ -68,7 +71,6 @@
            ;; delay expansion until it's a good time to lift expressions:
            (quasisyntax/loc stx (#%expression #,stx)))))))
 
-
 (define-syntax (provide/contract provide-stx)
   (syntax-case provide-stx (struct)
     [(_ p/c-ele ...)

collects/scribblings/reference/contracts.scrbl

@@ -1328,6 +1328,14 @@ flat contracts.}
 
 Extracts the predicate from a flat contract.}
 
+@defproc[(get-contract [v has-contract?]) contract?]{
+  Returns the contract attached to @scheme[v], if any.                                                     
+}
+
+@defproc[(has-contract? [v any/c]) boolean?]{
+  Returns @scheme[#t] if @scheme[v] is a function that
+  has a contract attached to it.
+}
 
 @defproc[(contract-first-order-passes? [contract contract?]
                                        [v any/c])