diff --git a/collects/file/scribblings/file.scrbl b/collects/file/scribblings/file.scrbl
index 17cd6d2e4c..02a4aeb950 100644
--- a/collects/file/scribblings/file.scrbl
+++ b/collects/file/scribblings/file.scrbl
@@ -1,5 +1,5 @@
 #lang scribble/doc
-@(require "common.ss")
+@(require "common.rkt")
 
 @title{@bold{File}: Racket File Format Libraries}
 
@@ -11,6 +11,7 @@
 @include-section["tar.scrbl"]
 @include-section["md5.scrbl"]
 @include-section["gif.scrbl"]
+@include-section["xpm.scrbl"]
 
 @(bibliography
   (bib-entry #:key "Gervautz1990"
diff --git a/collects/file/scribblings/xpm.scrbl b/collects/file/scribblings/xpm.scrbl
new file mode 100644
index 0000000000..12f78137be
--- /dev/null
+++ b/collects/file/scribblings/xpm.scrbl
@@ -0,0 +1,24 @@
+#lang scribble/doc
+@(require scribble/manual
+          (for-label racket/gui 
+                     file/xpm))
+
+@title[#:tag "xpm"]{XPM File Reading}
+
+@defmodule[file/xpm]
+
+The @racketmodname[file/xpm] library provides functions for
+reading XPM files and converting them to @racket[bitmap%] objects.
+
+@defproc[(xpm-read) xpm?]{Reads an XPM from the current input port.}
+
+@defproc[(xpm->bitmap% [xpm xpm?]) (is-a?/c bitmap%)]{Converts an XPM to a @racket[bitmap%].}
+
+@defstruct*[xpm ([var string?]
+                 [width exact-integer?]
+                 [height exact-integer?]
+                 [color-ht (hash/c symbol? (hash/c symbol? string?))]
+                 [x-hotspot (or/c false/c exact-integer?)]
+                 [y-hotspot (or/c false/c exact-integer?)]
+                 [pixels (listof (listof symbol?))]
+                 [extensions (listof string?)])]
diff --git a/collects/file/xpm.rkt b/collects/file/xpm.rkt
new file mode 100644
index 0000000000..f6129fa91a
--- /dev/null
+++ b/collects/file/xpm.rkt
@@ -0,0 +1,168 @@
+#lang racket/gui
+(require parser-tools/yacc
+         parser-tools/lex
+         (prefix-in : parser-tools/lex-sre))
+
+;;; Parser
+(define-tokens regular (VARIABLE STRING))
+(define-empty-tokens keywords (STATIC CHAR STAR BRACKET EQUALS LBRACE RBRACE SEMICOLON COMMA EOF))
+
+(define lex-xpm
+  (lexer
+   [(eof) (token-EOF)]
+   ["static" (token-STATIC)]
+   ["char" (token-CHAR)]
+   ["*" (token-STAR)]
+   ["[]" (token-BRACKET)]
+   ["=" (token-EQUALS)]
+   ["{" (token-LBRACE)]
+   ["}" (token-RBRACE)]
+   [";" (token-SEMICOLON)]
+   ["," (token-COMMA)]
+   [whitespace (lex-xpm input-port)]
+   [(:: "/*" (complement (:: any-string "*/" any-string)) "*/") (lex-xpm input-port)]
+   [(:: #\" (:* (:or (:~ #\") "\\\"")) #\")
+    (token-STRING (substring lexeme 1 (- (string-length lexeme) 1)))]
+   [(:+ (:or (char-range #\a #\z)
+             (char-range #\A #\Z)
+             (char-range #\0 #\9)
+             #\_
+             #\- ; Not really allowed but mini-plt uses it
+             ))
+    (token-VARIABLE lexeme)]))
+
+(define parse-raw-xpm
+  (parser (start xpm)
+          (tokens regular keywords)
+          (grammar (xpm [(STATIC CHAR STAR VARIABLE BRACKET EQUALS LBRACE
+                                 strings
+                                 RBRACE)
+                         (cons $4 $8)])
+                   (strings [(STRING) (list $1)]
+                            [(STRING COMMA strings) (list* $1 $3)]))
+          (end SEMICOLON)
+          (error (lambda (tok-ok? tok-name tok-value)
+                   (error
+                    'parse-raw-xpm
+                    (format 
+                     (if tok-ok? 
+                         "Did not expect token ~a"
+                         "Invalid token ~a")
+                     tok-name))))))
+
+;;; Struct
+
+(struct xpm (var width height color-ht x-hotspot y-hotspot pixels extensions) #:transparent)
+
+;;; Reading
+
+(define (xpm-read)
+  (match-define (cons var strings)
+                (parse-raw-xpm (λ () (lex-xpm (current-input-port)))))
+  (define-values (width height ncolors cpp x-hotspot y-hotspot extensions?)
+    (parse-values (first strings)))
+  (define-values (colors-strs pixels*ext-strs)
+    (split-at (rest strings) ncolors))
+  (define-values (pixels-strs ext-strs)
+    (split-at pixels*ext-strs height))
+  (xpm var width height
+       (parse-colors-ht cpp colors-strs)
+       x-hotspot y-hotspot
+       (parse-pixels cpp pixels-strs)
+       ext-strs))
+
+(define parse-values
+  (match-lambda
+    [(regexp #px"^\\s*(\\d+)\\s+(\\d+)\\s+(\\d+)\\s+(\\d+)$"
+             (list _ 
+                   (app string->number w)
+                   (app string->number h)
+                   (app string->number ncolors)
+                   (app string->number cpp)))
+     (values w h ncolors cpp #f #f #f)]))
+
+(define (in-list* n l)
+  (make-do-sequence
+   (λ ()
+     (values (λ (l)
+               (define-values (ret rest) (split-at l n))
+               (apply values ret))
+              (λ (l)
+               (define-values (ret rest) (split-at l n))
+               rest)
+              l
+              (λ (l)
+                (not (empty? l)))
+              (λ _ #t)
+              (λ _ #t)))))
+
+(define (split-string-at s n)
+  (values (substring s 0 n)
+          (substring s n)))
+
+(define (parse-colors-ht cpp ss)
+  (for/hasheq ([s (in-list ss)])
+    (define-values (chars rest*) (split-string-at s cpp))
+    (define rest (regexp-replace #px"^\\s+" rest* ""))
+    (define ps (regexp-split #px"\\s+" rest))
+    (values (string->symbol chars)
+            (for/hasheq ([(context color) (in-list* 2 ps)])
+              (values (string->symbol context)
+                      color)))))
+
+(define (split-string s n)
+  (for/list ([i (in-range 0 (/ (string-length s) n))])
+    (substring s (* i n) (* (add1 i) n))))
+
+(define (parse-pixels cpp ss)
+  (for/list ([row (in-list ss)])
+    (for/list ([color (in-list (split-string row cpp))])
+      (string->symbol color))))
+
+;;; Displaying
+
+(define (hex->number n)
+  (string->number n 16))
+
+(define (color->pen% ht c context)
+  (define c-ht (hash-ref ht c (λ () (error 'color->pen% "Unknown color ~e" c))))
+  (define code (hash-ref c-ht context (λ () (error 'color->pen% "Unknown context ~e for color ~e" context c))))
+  (define style
+    (match code
+      ["None" 'transparent]
+      [_ 'solid]))
+  (define color
+    (match code
+      ["None" "black"]
+      [(regexp #px"^#([\\da-fA-F]{6})" (list _ hex))
+       (match-define (list r g b) (split-string hex 2))
+       (make-object color% (hex->number r) (hex->number g) (hex->number b))]
+      [_
+       (error 'color->pen% "Cannot parse ~e" code)]))
+  (make-object pen% color 1 style))
+
+(define xpm->bitmap%
+  (match-lambda
+    [(xpm var width height color-ht x-hotspot y-hotspot pixels extensions)
+     (define the-bitmap (make-object bitmap% width height))
+     (define the-dc (new bitmap-dc% [bitmap the-bitmap]))
+     (send the-dc set-background (make-object color% "white"))
+     (for ([y (in-naturals)]
+           [row (in-list pixels)])
+       (for ([x (in-naturals)]
+             [color (in-list row)])
+         (send the-dc set-pen (color->pen% color-ht color 'c))
+         (send the-dc draw-point x y)))
+     the-bitmap]))
+
+(provide/contract
+ [struct xpm ([var string?]
+              [width exact-integer?]
+              [height exact-integer?]
+              [color-ht (hash/c symbol? (hash/c symbol? string?))]
+              [x-hotspot (or/c false/c exact-integer?)]
+              [y-hotspot (or/c false/c exact-integer?)]
+              [pixels (listof (listof symbol?))]
+              [extensions (listof string?)])]
+ [xpm-read (-> xpm?)]
+ [xpm->bitmap% (xpm? . -> . (is-a?/c bitmap%))])
\ No newline at end of file
diff --git a/collects/meta/props b/collects/meta/props
index 0d86dda811..dd0a3dc8e7 100755
--- a/collects/meta/props
+++ b/collects/meta/props
@@ -716,6 +716,7 @@ path/s is either such a string or a list of them.
 "collects/ffi/objc.rkt" responsible (mflatt) drdr:command-line (mzc *)
 "collects/ffi/unsafe/objc.rkt" responsible (mflatt) drdr:command-line (mzc *)
 "collects/file" responsible (mflatt)
+"collects/file/xpm.rkt" responsible (jay) drdr:command-line (gracket "-t" *)
 "collects/framework" responsible (robby)
 "collects/framework/collapsed-snipclass.rkt" drdr:command-line (gracket-text "-t" *)
 "collects/framework/comment-snip.rkt" drdr:command-line (gracket-text "-t" *)
@@ -1380,6 +1381,8 @@ path/s is either such a string or a list of them.
 "collects/tests/drracket/syncheck-test.rkt" drdr:command-line (gracket *)
 "collects/tests/drracket/teachpack.rkt" drdr:command-line (gracket *)
 "collects/tests/drracket/time-keystrokes.rkt" drdr:command-line (gracket-text "-t" *)
+"collects/tests/file/xpm-show.rkt" responsible (jay) drdr:command-line #f
+"collects/tests/file/xpm.rkt" responsible (jay) drdr:command-line (gracket "-t" *)
 "collects/tests/framework" responsible (robby)
 "collects/tests/framework/canvas.rkt" drdr:command-line (mzc "-k" *)
 "collects/tests/framework/debug.rkt" drdr:command-line (mzc "-k" *)
diff --git a/collects/tests/file/xpm-show.rkt b/collects/tests/file/xpm-show.rkt
new file mode 100644
index 0000000000..0616d27dc1
--- /dev/null
+++ b/collects/tests/file/xpm-show.rkt
@@ -0,0 +1,18 @@
+#lang racket/gui
+(require file/xpm)
+
+(define the-bitmap
+  (command-line #:program "xpm-show"
+                #:args (file)
+                (xpm->bitmap% (with-input-from-file file xpm-read))))
+
+(define frame (new frame% [label "XPM"]))
+
+(define canvas
+  (new canvas%
+       [parent frame]
+       [paint-callback
+        (λ (c dc)
+          (send dc draw-bitmap the-bitmap 0 0))]))
+
+(send frame show #t)
\ No newline at end of file
diff --git a/collects/tests/file/xpm.rkt b/collects/tests/file/xpm.rkt
new file mode 100644
index 0000000000..667685ccb0
--- /dev/null
+++ b/collects/tests/file/xpm.rkt
@@ -0,0 +1,18 @@
+#lang racket
+(require file/xpm
+         tests/eli-tester)
+
+(define tree-xpms
+  (for*/list ([collect (in-list (list "icons" "guibuilder"))]
+              [file (in-directory (collection-path collect))]
+              #:when (regexp-match #rx"\\.xpm$" (path->bytes file)))
+    file))
+
+(define (xpm-test f)
+  (test
+   (xpm->bitmap% (with-input-from-file f xpm-read))))
+
+(test
+ (for ([f (in-list tree-xpms)])
+   (test #:failure-prefix (path->string f)
+         (xpm-test f))))